home *** CD-ROM | disk | FTP | other *** search
/ Mac Power 1997 January / macpower199701.bin / AMUG / Publishing_19 / Alpha 6.5.sit / Tcl / Modes / tclMode.tcl / tclMode.tcl
Encoding:
Text File  |  1996-08-15  |  6.9 KB  |  281 lines  |  [TEXT/ALFA]
  1.  
  2. if $startingUp {
  3.     set tclMenu            "･269"
  4.     addMode Tcl dummyTcl {*.tcl} tclMenu
  5.     addMenu tclMenu
  6.     return
  7. }
  8.  
  9.  
  10. proc dummyTcl {} {}
  11. proc tclMenu {} {}
  12.  
  13. # The menu.
  14. menu -n $tclMenu -p tclMenuProc {
  15.     "/L<O<BloadProc"
  16.     "/Z<O<BtraceThisProc"
  17.     "/Z<O<UtraceTclProcﾉ"
  18.     "/D<O<UdumpTraces"
  19.     "(-"
  20.     "rebuildTclIndices"
  21.     "(-"
  22.     "<U/PprocDefinition"
  23.     "getVarValueﾉ"
  24. }
  25.  
  26. newModeVar Tcl prefixString {# } 0
  27. newModeVar Tcl wordWrap {0} 1
  28. newModeVar Tcl funcExpr {^proc *([+-a-zA-Z0-9]+)} 0
  29. newModeVar Tcl parseExpr {^proc *([+-a-zA-Z0-9]+)} 0
  30. newModeVar Tcl wordBreak {(¥$)?¥w+} 0
  31. newModeVar Tcl wordBreakPreface {([^a-zA-Z0-9_¥$]|.¥$)} 0
  32. newModeVar Tcl elecLBrace    1    1
  33. newModeVar Tcl elecRBrace    1    1
  34. newModeVar Tcl elecReturn    1    1
  35. newModeVar Tcl autoMark    0    1
  36. newModeVar Tcl electricTab 1 1
  37. newModeVar Tcl stringColor    green    0
  38. newModeVar Tcl commentColor    red    0
  39. newModeVar Tcl keywordColor    blue    0
  40.  
  41. set tclKeyWords {
  42.     then append array break case catch cd close concat continue elseif else eof 
  43.     error eval exec exit expr file flush foreach format for gets global glob 
  44.     history if incr info join lappend library lindex linsert list llength 
  45.     lrange lreplace lsearch lsort open pid proc puts pwd read regexp regsub 
  46.     rename return scancontext scan seek set source split string switch tell 
  47.     time trace unknown unset uplevel upvar while
  48.     
  49.     menu
  50. }
  51. if {[info exists Tclwords]} {set tclKeyWords [concat $tclKeyWords $Tclwords]}
  52. regModeKeywords -e {#} -c $TclmodeVars(commentColor) -k $TclmodeVars(keywordColor) Tcl $tclKeyWords -s $TclmodeVars(stringColor)
  53. unset tclKeyWords
  54.  
  55.  
  56. proc electricTclLeft {} {
  57.         global TclmodeVars
  58.  
  59.         if { [isSelection] } { deleteSelection }
  60.         if { [literalChar] } { insertText "¥{"; return }
  61.  
  62.         set pat {¥}[ ¥t¥r]*(else(if)?)[ ¥t¥r]*$}
  63.         if { !$TclmodeVars(elecLBrace) || ¥
  64.              (([lookAt [getPos]] != "¥r") && ([getPos] != [maxPos])) || ¥
  65.              [catch {search -s -f 0 -r 1 "¥}" [getPos]} res] || ¥
  66.              ![regexp $pat [getText [lindex $res 0] [getPos]] dum word] } {
  67.                 insertText "¥{"
  68.                 return
  69.         }
  70.         replaceText [lindex $res 0] [getPos] "¥} $word ¥{¥r"
  71.         indentLine
  72.         if { $word == "elseif" } {
  73.                 previousLine
  74.                 endOfLine
  75.         }
  76. }
  77. bind '¥{' <s> electricTclLeft Tcl
  78.  
  79.  
  80. proc electricTclRight {} {
  81.         global TclmodeVars
  82.                 
  83.         if { [isSelection] } { deleteSelection }
  84.         if { [literalChar] } { insertText "¥}"; return }
  85.         if { !$TclmodeVars(elecRBrace) || ¥
  86.              [regexp {[^ ¥t]} [getText [lineStart [getPos]] [getPos]]] } {
  87.                 insertText "¥}"
  88.                 blink [matchIt "¥}" [expr [getPos] - 2]]
  89.                 return
  90.         }
  91.         set start [lineStart [getPos]]
  92.         insertText "¥}"
  93.         backwardChar
  94.         indentLine
  95.         endOfLine
  96.         tclCarriageReturn
  97.         blink [matchIt "¥}" $start]
  98. }
  99. bind '¥}' <s> electricTclRight Tcl
  100.     
  101.  
  102. proc tclCarriageReturn {} {
  103.     global TclmodeVars
  104.     
  105.     if { [isSelection] } { deleteSelection }
  106.     insertText "¥r"
  107.     if {$TclmodeVars(elecReturn)} {
  108.         indentLine
  109.     }
  110. }
  111. bind '¥r' tclCarriageReturn Tcl
  112.  
  113.  
  114.  
  115.  
  116. proc tclMenuProc {menu item} {
  117.     global tclColoring
  118.  
  119.     eval $item
  120. }
  121.  
  122.  
  123. proc setTclMode {} {
  124.     changeMode "Tcl"
  125. }
  126.  
  127.  
  128. #===============================================================================
  129. proc TclDblClick {from to shift option control} {
  130.     global HOME auto_index auto_path
  131.     
  132.     select $from $to
  133.     set text [getSelect]
  134.  
  135.     # Is it a loadable proc?
  136.     if {[string length [set f [findCmd $text]]]} {
  137.         editMark $f $text
  138.         return
  139.     }
  140.  
  141.     if {[info exists "auto_index($text)"]} {
  142.         editMark "$auto_index($text)" $text
  143.         return
  144.     }
  145.     # Is it a built-in Alpha command?
  146.     set lines [grep "^･ $text " "$HOME:Help:Alpha Commands"]
  147.     if {[string length $lines]} {
  148.         editMark "$HOME:Help:Alpha Commands" $text
  149.         setWinInfo read-only 1
  150.         return
  151.     }
  152.     # Is it a core Tcl command?
  153.     set lines [grep "^     $text -" "$HOME:Help:Tcl Commands"]
  154.     if {[string length $lines]} {
  155.         editMark "$HOME:Help:Tcl Commands" $text
  156.         setWinInfo read-only 1
  157.         return
  158.     }
  159.     # Is it a global variable?
  160.      if {[llength [info globals [string trimleft $text {$}]]]==1} {
  161.         showVarValue [string trimleft $text {$}]
  162.         return
  163.     }
  164.     message "No docs $shift $control $option"
  165. }
  166.  
  167. proc procDefinition {} {
  168.     if {[llength [winNames]] && [string length [set sel [getSelect]]]} {
  169.         set func [listpick -L $sel -p {Proc?} [lsort -ignore [info procs]]]
  170.     } else {
  171.         set func [listpick -p {Proc?} [lsort -ignore [info procs]]]
  172.     }
  173.  
  174.     editMark [findCmd $func] $func
  175. }
  176.  
  177. #===============================================================================
  178. proc TclMarkFile {} {
  179.     set end [maxPos]
  180.     set pos 0
  181.     set l {}
  182.     set markExpr {^[ ¥t]*(itcl_class|class|proc|method|body)}
  183.     set class ""
  184.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  185.         set start [lindex $res 0]
  186.         set end [nextLineStart $start]
  187.         set t [getText $start $end]
  188.         switch [lindex $t 0] {
  189.             "proc" { set text [lindex $t 1] }
  190.             "method" { set text ${class}::[lindex $t 1] }
  191.             "body" { 
  192.                 regexp {[a-zA-Z_]+::[a-zA-Z_]+ } "[lindex $t 1] " text
  193.             }
  194.             "itcl_class" -
  195.             "class" { 
  196.                 set class [lindex $t 1]
  197.                 set text "${class} 000" 
  198.             }
  199.         }
  200.         set pos $end
  201.         set inds($text) [lineStart [expr $start - 1]]
  202.     }
  203.  
  204.     set already ""
  205.     
  206.     if {[info exists inds]} {
  207.         foreach f [lsort -ignore [array names inds]] {
  208.             set next [nextLineStart $inds($f)]
  209.             if { [string first "000" $f] != -1 } {
  210.                 set ff "Class '[lindex $f 0]'"
  211.             } elseif { [string first "::" $f] != -1 } {
  212.                 set ff " :: [lindex [split $f "::"] 2]"
  213.             } else {
  214.                 set ff $f
  215.             }
  216.             while { [lsearch -exact $already $ff] != -1 } {
  217.                 set ff "$ff "
  218.             }
  219.             lappend already $ff
  220.             setNamedMark $ff $inds($f) $next $next
  221.         }
  222.     }
  223. }
  224.  
  225. proc loadProc {} {
  226.     set    pos    [getPos]
  227.     if [catch {set p [findEnclosingProc $pos] } ] {
  228.         loadLine $pos
  229.     } else {
  230.         eval select $p
  231.         uplevel ¥#0 load    
  232.     }
  233.     goto $pos
  234. }
  235.  
  236. # If the first brace after 'proc' ends the current line, then
  237. # assume the argument was a single arg with no braces.
  238. proc findEnclosingProc { pos } {
  239.         set start [lindex [search -s -r 1 -f 0 {^(proc|class) } $pos] 0]
  240.  
  241.         # find the parameter block
  242.         set p1 [lindex [search -s -f 1 "¥{" $start] 0]
  243.         set p [matchIt "¥{" [expr $p1 +1]]
  244.         if { [string trim [getText $p1 [nextLineStart $p1]]] == "¥{" } {
  245.                 if { $p < $pos } {
  246.                         error
  247.                 } else {
  248.                         return [list $start [expr $p +1]]
  249.                 }
  250.         }
  251.  
  252.         # find the body
  253.         set p [lindex [search -s -f 1 "¥{" $p] 0]
  254.         set p [matchIt "¥{" [expr $p +1]]
  255.         incr p
  256.         if { $p < $pos } { error }
  257.         return [list $start $p]
  258. }
  259.  
  260. proc loadLine { pos } {
  261.     goto $pos
  262.     beginningLineSelect
  263.     endLineSelect
  264.     uplevel ¥#0 load    
  265. }
  266.  
  267. proc traceThisProc {} {
  268.     global tclMenu
  269.     # if we're tracing already then clear it
  270.     if {[llength [traceFunc status]]>2} { traceTclProc }
  271.     
  272.     set p [findEnclosingProc [getPos]]
  273.     
  274.     set func [lindex [getText $p [nextLineStart $p]] 1]
  275.     
  276.     traceFunc on $func ""
  277.     catch {markMenuItem $tclMenu {traceTclProcﾉ} on}
  278.     catch {enableMenuItem $tclMenu dumpTraces on}
  279.     message "Tracing '$func'ﾉ"
  280. }
  281.